カテゴリー
VBA

【数C】ExcelVBAで行列でできる不定方程式の解法【ゆっくり解説】

ExcelVBAで行列でできる不定方程式の解法マクロを作る
この動画のマクロはWindows11/Office2016で作成してます。

不定方程式の解法マクロ
Excel futei.xlsm
Google 不定方程式を解いてみる

Sub macro()
    a = 23
    b = 31
    c = 1

    kai = tokutei(a, b)
    
    Debug.Print "解  x= "; kai(1, 1) * c, "  y= "; kai(1, 2) * c
End Sub

Function tokutei(a, b)
    rt = ""
    
    'a,bの符号を正にする
    m_norm = Evaluate("{" & Sgn(a) & ",0;0," & Sgn(b) & "}")
    
    v = Evaluate("{" & a & ";" & b & "}")   'aとbの列ベクトル
    
    v = WorksheetFunction.MMult(m_norm, v)
    
    Do
        r = Int(v(1, 1) / v(2, 1))
        q = v(1, 1) Mod v(2, 1)
        If q = 0 Then
            '割り切れた
            Debug.Print "ユークリッドの互除法0"
            Debug.Print "|" & Right("    " & v(1, 1), 4); "| = |"; Right("    " & r, 4); "  0 ||" & Right("    " & v(2, 1), 4); " |"
            Debug.Print "|" & Right("    " & v(2, 1), 4); "|   |   0 -1 ||"; Right("     " & q, 4); " |"
            Debug.Print "最大公約数GCM", v(2, 1)
            rt = r & "," & rt
            Exit Do
        Else
            Debug.Print "ユークリッドの互除法1"
            Debug.Print "|" & Right("    " & v(1, 1), 4); "| = |"; Right("    " & r, 4); "  0 ||" & Right("    " & v(2, 1), 4); " |"
            Debug.Print "|" & Right("    " & v(2, 1), 4); "|   |   0 -1 ||"; Right("     " & q, 4); " |"
            Debug.Print
            
            v(1, 1) = v(2, 1)
            v(2, 1) = q
            If rt = "" Then
                rt = r
            Else
                rt = r & "," & rt
            End If
        End If
        DoEvents
    Loop
    
    Debug.Print "商の並び  ", rt
    r = Split(rt, ",")
    
    p = [{1,0;0,1}] '単位行列
    
    For i = 0 To UBound(r) + 1
        '逆行列をかけていく
        
        If i > UBound(r) Then
            s = m_norm
        Else
            s = Evaluate("{0,1;1,-" & r(i) & "}")
        End If
        p0 = WorksheetFunction.MMult(p, s)
        Debug.Print "|" & Right("    " & p(1, 1), 4); "  "; Right("    " & p(1, 2), 4); "| * |" & Right("    " & s(1, 1), 4); "  "; Right("    " & s(1, 2), 4); "| = |" & Right("    " & p0(1, 1), 4); "  "; Right("    " & p0(1, 2), 4); "|"
        Debug.Print "|" & Right("    " & p(2, 1), 4); "  "; Right("    " & p(2, 2), 4); "|   |" & Right("    " & s(2, 1), 4); "  "; Right("    " & s(2, 2), 4); "|   |" & Right("    " & p0(2, 1), 4); "  "; Right("    " & p0(2, 2), 4); "|"
        Debug.Print
        p = p0
        DoEvents
    Next

    tokutei = p
End Function
カテゴリー
VBA

【悪用厳禁】VBAでスクショ&クリックを繰り返す【ゆっくり解説】

ExcelVBAでスクショ&クリックを繰り返すしてみた
この動画のマクロはWindows11/Office2016で作成してます。

yahooのページでテスト

Sub Macro1()
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'Chromeを起動
    Set driver = CreateObject("Selenium.WebDriver")

    driver.AddArgument "--disable-blink-features=AutomationControlled"  'Seleniumの痕跡を隠す
    driver.Start "chrome"
    '4Kディスプレイにブラウザを表示
    driver.Window.SetSize 1074 * 1.2, 1524 * 1.2
    driver.Window.SetPosition 3840, 0
    
    
    ao_Url = "https://www.yahoo.co.jp/"
    driver.Get ao_Url
    
    
    'ブラウザのスクリーンショットを撮る
    Screenshot_fileName = fso.BuildPath(ThisWorkbook.Path, "test1.png")
    driver.TakeScreenshot.SaveAs Screenshot_fileName
    
    'ヘッダー部分のスクリーンショットを撮る
    Screenshot_fileName = fso.BuildPath(ThisWorkbook.Path, "test2.png")
    Set o_elem1 = driver.FindElementsByCss("#Masthead")
    o_elem1(1).TakeScreenshot.SaveAs Screenshot_fileName

    
    
    Set o_elem1 = driver.FindElementsByCss("body")
    'o_elem1.Item(1).ClickByOffset 200, 233
    driver.Actions.MoveByOffset(200, 233).Click.Perform


    MsgBox "エンドしますよ", , "ボタンを押して進めてください"


    'ブラウザを閉じる
    driver.Quit
    Set driver = Nothing
 
End Sub

青空文庫のページでテスト

#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Declare  Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub Macro()
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'ダウンロード先のフォルダーを消して作成
    download_dir = fso.BuildPath(ThisWorkbook.Path, "screenshot")
    If (fso.FolderExists(download_dir) = True) Then
        '// フォルダが存在する
        fso.DeleteFolder download_dir, True
    End If
    MkDir download_dir
    
    'Chromeを起動
    Set driver = CreateObject("Selenium.WebDriver")

    driver.AddArgument "user-data-dir=" & fso.BuildPath(ThisWorkbook.Path, "edge_vba") 'Cookieを使う
    driver.AddArgument "--disable-blink-features=AutomationControlled"  'Seleniumの痕跡を隠す
    driver.Start "chrome"
    
    '4Kディスプレイに適当な大きさのブラウザを表示
    driver.Window.SetSize 1074 * 1.2, 1524 * 1.2
    driver.Window.SetPosition 3840, 0
    
    '定数
    max_page = 300   'ページ処理の最大数
    f_next_key = 0 'ページ送りの方向    0:左 1:右
    
    'ao_Url = "https://aozora.binb.jp/reader/main.html?cid=623"
    ao_Url = "https://aozora.binb.jp/reader/main.html?cid=50420"
    driver.Get ao_Url
  
    'MsgBoxでスクショを始めたいところまで待つ
    MsgBox "スタートしますよ"
    Call Sleep(3000)  '3秒待つ
    
    '次のタブに制御を移す
    Set o_elem = driver.FindElementsByCss("#contents>iframe")
    driver.SwitchToFrame o_elem.Item(1)
    
    'bodyエレメントの大きさからクリックすべき位置を算出
    Set o_elem = driver.FindElementsByCss("body")
    Set body_size = o_elem.Item(1).Size
    click_x = Int(body_size.Width * (0.5 + (f_next_key - 0.5) / 2))
    click_y = Int(body_size.Height / 2)

    'スクショ&クリックを繰り返す
    f_end = 0
    For i = 0 To max_page
        'ブラウザのスクリーンショットを撮る
        Screenshot_fileName = fso.BuildPath(download_dir, "screenshot" & Right("00000" & i, 4) & ".png")
        driver.TakeScreenshot.SaveAs Screenshot_fileName
        
        If f_end = 0 Then
            'ページを送る
            Set o_elem = driver.FindElementsByCss("body")
            o_elem.Item(1).ClickByOffset click_x, click_y
    
            '次のページが表示されるまで待つ
            Call Sleep(2000)  '2秒待つ

            'bodyのcursorの定義を更新させるためにマウスを動かす
            driver.Actions.MoveByOffset(1, 1).Perform
            Debug.Print i, o_elem.Item(1).CssValue("cursor")
            If o_elem.Item(1).CssValue("cursor") = "default" Then
                f_end = 1    '最後のページ
            End If
        Else
            Exit For
        End If
        DoEvents
    Next

    'ブラウザを閉じる
    driver.Quit
    Set driver = Nothing
 
End Sub
カテゴリー
PC

【PSDTool 】ゆっくりムービーメーカー4で四国めたんを動く立ち絵で動かしてみた【ゆっくり解説】

ずんだもん
ずんだもん.pfv
立ち絵変換_ずんだもん.bat.txt

四国めたん
四国めたん.pfv
立ち絵変換_四国めたん.bat.txt

カテゴリー
VBA

VBAでGoogle画像検索の画像を一括でダウンロードしてみた

ExcelVBAでGoogle画像検索の画像を一括でダウンロードしてみた
この動画のマクロはWindows11/Office2016で作成してます。

画像をクリックしてダウンロード


#If VBA7 Then
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
    Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#Else
    Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
    Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#End If

Const c_ダウンロード最大数 = 99
    

Sub test1()
    'クリックするやつ
    Call dlImgGoogle("ゆっくり魔理沙", "thumbnail")

End Sub

Sub dlImgGoogle(keyword, FolderName)

    Dim driver As New Selenium.WebDriver

    If keyword = "" Then Exit Sub


    'このExcelファイルのパス
    CurrentDirectory = ThisWorkbook.path
    

    Set fso = CreateObject("Scripting.FileSystemObject")
    If FolderName = fso.GetAbsolutePathName(FolderName) Then
        path = FolderName
        Debug.Print "絶対パス  path = "; path
        
    Else
        path = fso.BuildPath(CurrentDirectory, FolderName)
        Debug.Print "相対パス " & FolderName & "->path = "; path
    End If
    
    'フォルダーがない場合フォルダーを作成する。
    If Not (fso.FolderExists(path)) Then
        Debug.Print "新規作成パス  path = "; path
        fso.CreateFolder path
    End If

    
    driver.Start "Chrome"
    driver.Get "https://www.google.co.jp/search?&source=lnms&tbm=isch&&q=" & keyword
    driver.Wait 100
  
  
    '

検索結果

弟ノードの1番目のdivの配下で、role=buttonの属性を持つaを取得 Set dom_a = driver.FindElementsByXPath("//h1[contains(text(), '検索結果')]/following-sibling::div/div[1]//a[contains(@role,'button')]") Debug.Print "検索数1", dom_a.Count '拡張子を判定するための正規表現 Set re = CreateObject("VBScript.RegExp") re.IgnoreCase = True re.Pattern = "\.(jpeg|jpg|png|bmp|gif)" For i = 1 To WorksheetFunction.Min(dom_a.Count, c_ダウンロード最大数) '画像クリック driver.ExecuteScript "arguments[0].click();", dom_a(i) driver.Wait 200 '検索結果の弟ノードの2番目のdivの中から、aを親に持つimgを取得 Set dom_img = driver.FindElementsByXPath("//h1[contains(text(), '検索結果')]/following-sibling::div/div[2]//a[contains(@role,'link')]/img") Debug.Print "検索数2", dom_img.Count 'imgのsrcにurlが出現するまで待つ wait_time = 500 'うまくいかない場合ここを伸ばす For t = 1 To 20 '最初の画像(i=1)のみ1番目のimgに目的のオブジェクトが存在する。それ以外は2番目 If i = 1 Then driver.Wait wait_time str_name = dom_img(1).Attribute("alt") str_url = dom_img(1).Attribute("src") Else: driver.Wait wait_time str_name = dom_img(2).Attribute("alt") str_url = dom_img(2).Attribute("src") End If 'srcがhttp形式になったらforを抜ける If InStr(str_url, "http") > 0 Then Exit For DoEvents Next 'urlとして有効なものはダウンロードする If InStr(str_url, "http") > 0 Then '拡張子を取得 Set reMatch = re.Execute(str_url) If reMatch.Count = 1 Then '画像種別 str_ext = reMatch(0).submatches(0) str_ext = Replace(str_ext, "jpeg", "jpg") 'jpegはjpgに統一 Else '拡張子が不明なものはjpgにする str_ext = "jpg" End If '画像のダウンロード先 '検索文字列-1234.jpgのような名前にする img_file_name = fso.BuildPath(path, keyword & WorksheetFunction.Text(i, "-00#.") & str_ext) '画像ダウンロード Debug.Print "img_file_name= "; img_file_name dowonloaStatus = URLDownloadToFile(0, str_url, img_file_name, 0, 0) 'Debug.Print "dowonloaStatus= "; dowonloaStatus If dowonloaStatus = 0 Then 'Debug.Print "画像ダウンロードできました" Else Debug.Print "画像ダウンロードできませんでした:"; str_url End If DoEvents Else Debug.Print "画像urlが取得できませんでした:"; str_url End If Next driver.Quit Set driver = Nothing End Sub

url一覧を出力するjavascriptの関数

function AF_initDataCallback(x) {
	data1=x.data[56][1][0][0][1][0]

	for(i=0;i<=data1.length-1;i++) {
		data2=data1[i][0][0]["444383007"]
		if (data2[1]==null) {break}
		item_img_url=data2[1][3][0]
		item_name=data2[1][23]["2008"][1]
		console.log(i+" "+ (data2[1][23]["2008"][1]))
	}
}

url一覧を出力するjavascriptの関数を使ってダウンロード

#If VBA7 Then
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
    Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#Else
    Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
    Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
#End If

Const c_ダウンロード最大数 = 99
    

Sub test2()
    'クリックしないやつ
    Call dlImgGoogle("ゆっくり魔理沙", "thumbnail")
End Sub

Sub dlImgGoogle2(keyword, FolderName)

    Dim driver As New Selenium.WebDriver

    'このExcelファイルのパス
    CurrentDirectory = ThisWorkbook.path
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    If FolderName = fso.GetAbsolutePathName(FolderName) Then
        path = FolderName
        Debug.Print "絶対パス  path = "; path
        
    Else
        path = fso.BuildPath(CurrentDirectory, FolderName)
        Debug.Print "相対パス " & FolderName & "->path = "; path
    End If

    If Not (fso.FolderExists(path)) Then
        Debug.Print "新規作成パス  path = "; path
        fso.CreateFolder path
    End If



    driver.Start "Chrome"
    driver.Get "https://www.google.co.jp/search?&source=lnms&tbm=isch&&q=" & keyword
    driver.Wait 100
  
    
    '検索文字列keywordを含んだ

アーカイブ

カテゴリー